VERSION 5.00
Begin {AC0714F6-3D04-11D1-AE7D-00A0C90F26F4} Connect 
   ClientHeight    =   7545
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   8895
   _ExtentX        =   15690
   _ExtentY        =   13309
   _Version        =   393216
   Description     =   "#101"
   DisplayName     =   "#100"
   AppName         =   "Visual Basic"
   AppVer          =   "Visual Basic 98 (ver 6.0)"
   LoadName        =   "None"
   LoadBehavior    =   2
   RegLocation     =   "HKEY_CURRENT_USER\Software\Microsoft\Visual Basic\6.0"
   SatName         =   "OCXDirect"
   CmdLineSupport  =   -1  'True
End
Attribute VB_Name = "Connect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private WithEvents MenuHandler As CommandBarEvents   'command bar event handler
Attribute MenuHandler.VB_VarHelpID = -1
Private m_MenuCommandBar As CommandBarControl

Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As Any, ByVal lpType As Any) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long

Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As Long, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Integer = 260

Private Const RT_RCDATA As Long = 10
Private Const DONT_RESOLVE_DLL_REFERENCES As Long = 1
Private Const LOAD_LIBRARY_AS_DATAFILE As Long = 2

Private m_VBInst As VBIDE.VBE
Private m_ProjPath As String

Private Const cstrNameExtension As String = "Direct"
Private Const cstrOurLibName As String = "DirectOCXTypes"

Private Function OCXRefInfoFromOCA(strOCAFile As String) As String
Dim hInst As Long
Dim hRsrc As Long
Dim hGlobal As Long
Dim pData As Long
Dim dwOffset As Long
    hInst = LoadLibraryEx(strOCAFile, 0, DONT_RESOLVE_DLL_REFERENCES Or LOAD_LIBRARY_AS_DATAFILE)
    If hInst Then
        hRsrc = FindResource(hInst, CLng(1), RT_RCDATA)
        If hRsrc Then
            hGlobal = LoadResource(hInst, hRsrc)
            If hGlobal Then
                pData = LockResource(hGlobal)
                With VBoost
                    dwOffset = .Deref(.UAdd(pData, 40))
                    pData = .UAdd(pData, dwOffset)
                End With
                OCXRefInfoFromOCA = StrConv(SysAllocStringByteLen(pData, lstrlen(pData)), vbUnicode)
            End If
        End If
        FreeLibrary hInst
    End If
End Function

Private Function TLIForOCXFromOCA(strOCAFile As String) As TLI.TypeLibInfo
Dim strOCXData As String
    strOCXData = OCXRefInfoFromOCA(strOCAFile)
    If Len(strOCXData) Then Set TLIForOCXFromOCA = TLIFromRefInfo(strOCXData)
End Function

Private Function TLIFromRefInfo(RefInfo As String) As TLI.TypeLibInfo
Dim MinorVerPos As Integer
Dim MajorVerPos As Integer
Dim LCIDPos As Integer
Dim EndPos As Long
Dim fMoreInfo As Boolean
Dim lPos As Long
    On Error Resume Next
    Set TLIFromRefInfo = New TypeLibInfo
    MinorVerPos = InStr(1, RefInfo, "#") + 1
    MajorVerPos = InStr(MinorVerPos, RefInfo, ".") + 1
    LCIDPos = InStr(MinorVerPos, RefInfo, "#") + 1
    EndPos = InStr(LCIDPos, RefInfo, "#")
    fMoreInfo = EndPos
    If EndPos = 0 Then EndPos = Len(RefInfo) + 1
    TLIFromRefInfo.LoadRegTypeLib _
        Mid$(RefInfo, 1, MinorVerPos - 2), _
        CInt(Mid$(RefInfo, MinorVerPos, MajorVerPos - MinorVerPos - 1)), _
        CInt(Mid$(RefInfo, MajorVerPos, LCIDPos - MajorVerPos - 1)), _
        CLng(Mid$(RefInfo, LCIDPos, EndPos - LCIDPos))
    If Err Then
        'Try to load off the file name.
        If fMoreInfo Then
            If Len(m_ProjPath) = 0 Then
                m_ProjPath = m_VBInst.ActiveVBProject.FileName
                lPos = Len(m_ProjPath)
                Do Until Mid$(m_ProjPath, lPos, 1) = "\"
                    lPos = lPos - 1
                Loop
                m_ProjPath = Left$(m_ProjPath, lPos)
            End If
            Err.Clear
            TLIFromRefInfo.ContainingFile = m_ProjPath & Mid$(RefInfo, EndPos + 1, InStr(EndPos + 1, RefInfo, "#") - EndPos - 1)
            If Err = 0 Then Exit Function
        End If
        'Just return Nothing.  Don't care why the error happened.
        Set TLIFromRefInfo = Nothing
        Err.Clear
    End If
End Function

Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
    Set m_VBInst = Application
    If ConnectMode = vbext_cm_AfterStartup Then
        AddinInstance_OnStartupComplete custom()
    End If
End Sub

Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
    If Not m_MenuCommandBar Is Nothing Then
        m_MenuCommandBar.Delete
        Set m_MenuCommandBar = Nothing
        Set MenuHandler = Nothing
    End If
    Set m_VBInst = Nothing
End Sub

Private Sub AddinInstance_OnStartupComplete(custom() As Variant)
    Set m_MenuCommandBar = AddToAddInCommandBar(LoadResString(102), LoadResPicture(1, vbResBitmap))
    If Not m_MenuCommandBar Is Nothing Then
        'sink the event
        Set MenuHandler = m_VBInst.Events.CommandBarEvents(m_MenuCommandBar)
    End If
End Sub

Private Function AddToAddInCommandBar(sCaption As String, oBitmap As Picture) As Office.CommandBarControl
Dim Count As Integer
Dim cbMenuCommandBar As Office.CommandBarControl  'command bar object
Dim cbMenu As CommandBar
    
    On Error GoTo Error
    'see if we can find the Add-Ins menu
    Set cbMenu = m_VBInst.CommandBars("Add-Ins")
        If cbMenu Is Nothing Then
        'not available so we fail
        Exit Function
    End If
    
    'add it to the command bar
    With cbMenu.Controls
        Set cbMenuCommandBar = .Add(1)
        Count = .Count - 1
        If .Item(Count).BeginGroup And _
            Not .Item(Count - 1).BeginGroup Then
            'this s the first addin being added so it needs a separator
            cbMenuCommandBar.BeginGroup = True
        End If
    End With
    
    'set the caption
    cbMenuCommandBar.Caption = sCaption
    If Not oBitmap Is Nothing Then
        'copy the icon to the clipboard
        Clipboard.SetData oBitmap
        'set the icon for the button
        cbMenuCommandBar.PasteFace
    End If
    Set AddToAddInCommandBar = cbMenuCommandBar
    Exit Function
Error:
End Function

Private Function TLIForRefsFromVBP(VBPFile As String) As VBA.Collection
Dim fNum As Integer
Dim strLine As String
Dim TLInf As TypeLibInfo
    'Make sure we have a collection, even if it ends up empty.
    Set TLIForRefsFromVBP = New VBA.Collection
    fNum = FreeFile
    Open VBPFile For Input As #fNum
    Do Until EOF(fNum)
        Line Input #fNum, strLine
        'Assume default format
        If Left$(strLine, 7) = "Object=" Then
            Set TLInf = TLIFromRefInfo(Mid$(strLine, 8, InStr(8, strLine, ";") - 8))
        ElseIf Left$(strLine, 13) = "Reference=*\G" Then
            Set TLInf = TLIFromRefInfo(Mid$(strLine, 14))
        End If
        If Not TLInf Is Nothing Then
            TLIForRefsFromVBP.Add TLInf, TLInf.Name
            Set TLInf = Nothing
        End If
    Loop
    Close fNum
End Function

Private Function TempFile(strBaseName As String) As String
    TempFile = String$(MAX_PATH, 0)
    GetTempPath MAX_PATH, TempFile
    TempFile = StrConv(TempFile, vbFromUnicode)
    GetTempFileName StrPtr(TempFile), strBaseName, 0, StrPtr(TempFile)
    TempFile = StrConv(TempFile, vbUnicode)
    TempFile = Left$(TempFile, InStr(TempFile, vbNullChar) - 1)
End Function

Private Sub MenuHandler_Click(ByVal CommandBarControl As Object, Handled As Boolean, CancelDefault As Boolean)
Dim TLInfOCX As TLI.TypeLibInfo
Dim TLInfTmp As New TLI.TypeLibInfo
Dim CCInfo As TLI.CoClassInfo

Dim ref As VBIDE.Reference
Dim refPath As String
Dim refName As String

Dim strNoFile As String
Dim vbProj As VBIDE.VBProject
Dim strProjPath As String
Dim refOurs As VBIDE.Reference
Dim strTLBName As String
Dim strTLBTmp As String

Dim strTmp As String
Dim fCompareGuids As Boolean
Dim VBPControls As VBA.Collection

Dim ICTL As ICreateTypeLib2
Dim ITLCreate As ITypeLib
Dim CTI As ICreateTypeInfo
Dim NewGuid As VBGUID
Dim hr As Long
Dim fHaveImports As Boolean
Dim tdesc As TYPEDESC
    
    If VBoost Is Nothing Then InitVBoost
    
    Handled = True
    Set vbProj = m_VBInst.ActiveVBProject
    strProjPath = vbProj.FileName
    If Len(strProjPath) = 0 Then
        MsgBox "Please save project file and try again.", vbExclamation
        Exit Sub
    End If
    'Make an ICreateTypeLib pointer to dump data to
    strTLBTmp = TempFile("~FC")
    Set ICTL = CreateTypeLib2(SYS_WIN32, strTLBTmp)
    Set ITLCreate = ICTL
    'Might have change, initialized as needed
    m_ProjPath = vbNullString
    For Each ref In vbProj.References
        'Cache FastCtlTypes reference
        On Error Resume Next
        refPath = ref.FullPath
        If Err Then
            Err.Clear
            'This will happen if the referenced OCA is
            'loaded as a project of this group.  In this
            'case, fall back on the VBP file, which may be
            'out of date, but is better than nothing.
            If VBPControls Is Nothing Then
                Set VBPControls = TLIForRefsFromVBP(strProjPath)
            End If
            Set TLInfOCX = VBPControls.Item(ref.Name)
            If Err Then
                strNoFile = strNoFile & ", " & ref.Name
                refPath = vbNullString
            Else
                refPath = vbNullString
                Set TLInfTmp = Nothing
                GoTo HaveTLInfOCX
            End If
        End If
        On Error GoTo RefError
        If StrComp(".oca", Right$(refPath, 4), vbTextCompare) = 0 Then
            Set TLInfOCX = TLIForOCXFromOCA(refPath)
HaveTLInfOCX:
            If Not TLInfOCX Is Nothing Then
                fCompareGuids = Len(refPath)
                If fCompareGuids Then
                    TLInfTmp.ContainingFile = refPath
                End If
                refName = TLInfOCX.Name
                For Each CCInfo In TLInfOCX.CoClasses
                    'We should be able to check CCInfo.AttributeMask
                    'for TYPEFLAG_FCONTROL, but not all controls
                    'cooperate by setting the correct flags in the
                    'typelib. If we can find a typeinfo with the same
                    'name and GUID in the OCA as in the OCX, then
                    'this isn't an extended control
                    On Error Resume Next
                    If fCompareGuids Then
                        If CCInfo.Guid = TLInfTmp.TypeInfos.NamedItem(CCInfo.Name).Guid Then
                            Set CCInfo = Nothing
                        End If
                    ElseIf 0 = (CCInfo.AttributeMask And TYPEFLAG_FCONTROL) Then
                            Set CCInfo = Nothing
                    End If
                    If Not CCInfo Is Nothing Then
                        Set CTI = ICTL.CreateTypeInfo(CCInfo.Name & cstrNameExtension, TKIND_ALIAS)
                        tdesc.vt = VT_USERDEFINED
                        tdesc.lptdesc_lpadesc_hreftype = CTI.AddRefTypeInfo(CCInfo.ITypeInfo)
                        CTI.SetTypeDescAlias VarPtr(tdesc)
                        CTI.LayOut
                        If Err = 0 Then fHaveImports = True
                        Set CCInfo = Nothing
                    End If
                    On Error GoTo RefError
                Next
            End If
        ElseIf ref.Name = cstrOurLibName Then
            Set refOurs = ref
        End If
NextRef:
    Next
    'The collection may hold a reference which locks
    'the typelib we're overwriting.  Make sure it's released.
    Set VBPControls = Nothing
    On Error GoTo OtherError
    strTLBName = Left$(strProjPath, Len(strProjPath) - 4) & cstrOurLibName & ".tlb"
    If fHaveImports Then
        'Make sure we actually have something to generate
        NewGuid = CoCreateGuid
        ICTL.SetName cstrOurLibName
        ICTL.SetGuid NewGuid
        ICTL.SetDocString LoadResString(103)
        ICTL.SetVersion 1, 0
        ICTL.SetLibFlags LIBFLAG_FHIDDEN
        ICTL.SaveAllChanges
        If Len(strNoFile) Then
            MsgBox "Can't load files for the following referenced libraries:" & _
                vbCrLf & Mid$(strNoFile, 3), vbExclamation
        End If
    Else
        Set ICTL = Nothing
        Set ITLCreate = Nothing
        On Error Resume Next
        Kill strTLBTmp
        On Error GoTo OtherError
    End If
    'Even if we don't have anything to generate, we still
    'want to remove a lib we created earlier
    If Not refOurs Is Nothing Then
        'FullPath only works before removal from the collection
        On Error Resume Next
        strTmp = refOurs.FullPath
        If Err Then
            vbProj.References.Remove refOurs
        Else
            'Make sure TLInfTmp is Nothing.  Otherwise,
            'we could unregister a random library if
            'setting .ContainingFile fails.
            Set TLInfTmp = Nothing
            TLInfTmp.ContainingFile = strTmp
            'We're generating a new GUID for pass, so the
            'previous version of this library needs to be
            'removed from the references collection, unregistered,
            'and deleted (in the case where the project name changed)
            vbProj.References.Remove refOurs
            TLInfTmp.UnRegister
            Set TLInfTmp = Nothing
            Kill strTLBName
            If StrComp(strTmp, strTLBName, vbTextCompare) Then
                'The library has moved or been renamed
                'since the last pass.  Clean up.
                'Note: This errs on the side of too much cleanup,
                'but the library is easy enough to regenerate if
                'a project has been 'saved as' and the old project
                'still needs to be valid.
                'Kill the TLB file we generated
                Kill strTmp
            End If
        End If
        On Error GoTo OtherError
    End If
    If fHaveImports Then
        'Make a final check to see if we need to clean up a previous file
        On Error Resume Next
        TLInfTmp.ContainingFile = strTLBName
        If Err = 0 Then
            TLInfTmp.UnRegister
            Set TLInfTmp = Nothing
            Kill strTLBName
        End If
        On Error GoTo OtherError
        Set ITLCreate = Nothing
        Set ICTL = Nothing 'Remove references to generated typelib
        Name strTLBTmp As strTLBName
        strTLBTmp = vbNullString
        TLInfTmp.ContainingFile = strTLBName
        'If we don't register this here, then the
        'FullPath property fails to work
        TLInfTmp.Register
        vbProj.References.AddFromFile strTLBName
    End If
    Exit Sub
OtherError:
    MsgBox Err.Description, vbExclamation
    If Len(strTLBTmp) Then
        On Error Resume Next
        Kill strTLBTmp
        On Error GoTo 0
    End If
    Exit Sub
RefError:
    Resume NextRef
End Sub


